home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / avl.lisp < prev    next >
Encoding:
Text File  |  1991-10-04  |  17.0 KB  |  504 lines
  1. ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                    AVL trees
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: avl.lisp,v 2.8 1991/10/04 22:42:44 rz Exp $
  8.  
  9. (in-package "WEYLI")
  10.  
  11.  
  12. ;; FIXTHIS:  This is a stupid place for this code
  13.  
  14. (defmacro choose (seq (var n . options) &body body)
  15.   (cond ((getf options :allow-repeats)
  16.      `(choose-repeats% ,seq ,n (lambda (,var) ,@body)))
  17.     (t `(choose% ,seq ,n (lambda (,var) ,@body)))))
  18.  
  19. (defmethod choose% ((vars list) n fn)
  20.   (unless (or (null n) (lisp:integerp n))
  21.     (error "Invalid count argument to CHOOSE: ~D" n))
  22.   (labels ((pick (vars n so-far)
  23.          (declare (fixnum n))
  24.          (cond ((lisp:zerop n)
  25.             (%funcall fn so-far))
  26.            (t (pick (rest vars) (lisp:1- n) (cons (first vars) so-far))
  27.               (if (> (length vars) n)
  28.               (pick (rest vars) n so-far))))))
  29.     (let ((len (length vars)))
  30.       (declare (fixnum len))
  31.       (cond ((lisp:> n len)
  32.          (error "Not that many elements in vars"))
  33.         ((or (lisp:= n len) (lisp:zerop len))
  34.          (%funcall fn vars))
  35.         ((lisp:minusp n)
  36.          (pick vars (lisp:+ len n) ()))       
  37.         (t (pick vars n ()))))))
  38.  
  39. (defmethod choose-repeats% ((vars list) n fn)
  40.   (unless (or (null n) (lisp:integerp n))
  41.     (error "Invalid count argument to CHOOSE: ~D" n))
  42.   (labels ((pick (vars n so-far)
  43.          (declare (fixnum n))
  44.          (cond ((lisp:zerop n)
  45.             (%funcall fn so-far))
  46.            (t (loop while vars do
  47.              (pick vars (lisp:1- n) (cons (first vars) so-far))
  48.              (setq vars (rest vars)))))))
  49.     (let ((len (length vars)))
  50.       (declare (fixnum len))
  51.       (cond ((lisp:> n len)
  52.          (error "Not that many elements in vars"))
  53.         ((lisp:minusp n)
  54.          (pick vars (lisp:+ len n) ()))       
  55.         (t (pick vars n ()))))))
  56.  
  57. ;; FIXTHIS: At some point put in code for even and odd permutations.
  58. (defmacro permute (seq (var . options) &body body)
  59.   (declare (ignore options))
  60.   `(permute% ,seq (lambda (,var) ,@body)))
  61.  
  62. (defmethod permute% ((seq list) fun)
  63.   (labels ((pick (vars so-far)
  64.          (cond ((null vars) (%funcall fun so-far))
  65.            (t (loop for v in vars
  66.                 do (pick (remove v vars) (cons v so-far)))))))
  67.     (pick seq nil)))
  68.              
  69.  
  70. ;; Need to do the non-mutating version also.  I think this can be done
  71. ;; by just changin update-node...
  72.  
  73. ;; This code comes is derived from code that was originally written by
  74. ;; Bruce Donald.
  75.  
  76. ;; AVL trees
  77.  
  78. (defclass avl-tree (has-comparison)
  79.   ((root :initform nil
  80.      :accessor avl-root)))
  81.  
  82. (defclass avl-node (set-element)
  83.      ((left :initform nil :initarg :left :accessor avl-left)
  84.       (right :initform nil :initarg :right :accessor avl-right)
  85.       (balance :initform 0 :initarg balance :accessor avl-balance)))
  86.  
  87. (defclass avl-tree-elements-as-singletons (set-elements-as-singletons)
  88.      ())
  89.  
  90. (defclass avl-node-as-pairs (set-element2 avl-node)
  91.      ())
  92.  
  93. (defclass avl-tree-elements-as-pairs (set-elements-as-pairs)
  94.      ())
  95.  
  96. (defclass simple-avl-tree (avl-tree avl-tree-elements-as-singletons)
  97.      ())
  98.  
  99. (defclass avl-tree-of-pairs (avl-tree avl-tree-elements-as-pairs)
  100.      ())
  101.  
  102. (defmethod print-object ((tree avl-tree) stream)
  103.   (format stream "#<AVL tree: ~D elts>" (avl-size tree)))
  104.  
  105. (defmethod print-object ((node avl-node) stream)
  106.   (format stream "<AVL~[-~;=~;+~]: ~S>"
  107.       (1+ (avl-balance node)) (element-key node)))
  108.  
  109. #+ignore ;; This is for debugging
  110. (defmethod pretty-print-object ((node avl-node) &optional (stream *standard-output*))
  111.   (labels ((indent (n)
  112.          (loop for i below n do (princ " " stream)))
  113.        (pp (node indent)
  114.          (when (avl-left node)
  115.            (indent indent)
  116.            (format stream  "L: ~S~%" (avl-left node))
  117.            (pp (avl-left node) (lisp:+ 2 indent)))
  118.          (when (avl-right node)
  119.            (indent indent)
  120.            (format stream  "R: ~S~%" (avl-right node))
  121.            (pp (avl-right node) (lisp:+ 2 indent)))))
  122.     (format stream "~&Root: ~S~%" node)
  123.     (pp node 2)))
  124.  
  125. ;; This is used to update a node with new information since we don't
  126. ;; know all the information that could be stored in a node we've assumed
  127. ;; they can all be lumped into args. 
  128. (defmethod update-node ((node avl-node) balance left right &rest args)
  129.   (declare (ignore args))
  130.   (setf (avl-balance node) balance)
  131.   (setf (avl-left node) left)
  132.   (setf (avl-right node) right)
  133.   node)
  134.  
  135. (defmethod avl-size ((tree avl-tree))
  136.   (let ((root (avl-root tree)))
  137.     (if root (avl-size root)
  138.     0)))
  139.  
  140. (defmethod avl-size ((node avl-node))
  141.   (let ((left (avl-left node))
  142.     (right (avl-right node)))
  143.     (1+ (lisp:+ (if left (avl-size left) 0)
  144.        (if right (avl-size right) 0)))))
  145.  
  146. (defmethod empty? ((tree avl-tree))
  147.   (null (avl-root tree)))
  148.  
  149. ;; This determines the height of an AVL tree and also checks if your
  150. ;; tree is out of balance or "Koyaanisquatsi" in Hopi Indian. Actual
  151. ;; height difference should be the same as the balance value, and
  152. ;; should be in the range {-1,0,1}.
  153.  
  154. (defmethod avl-height ((tree avl-tree))
  155.   (let ((root (avl-root tree)))
  156.     (if root (avl-height root) 0)))
  157.  
  158. (defmethod avl-height ((node avl-node))
  159.   (let ((hl (if (avl-left node) (avl-height (avl-left node))
  160.         0))
  161.     (hr (if (avl-right node) (avl-height (avl-right node))
  162.         0)))
  163.     (cond ((not (eql (lisp:- hr hl) (avl-balance node)))
  164.        (format t "~
  165.               The actual height difference ~S does not agree with the ~%~
  166.               balance entry ~S for node ~S"
  167.            (lisp:- hr hl) (avl-balance node) node))
  168.       ((lisp:> (lisp:abs (avl-balance node)) 1)
  169.        (format t "Node ~S is Koyaanisquatsi, its balance value is ~S"
  170.            node (avl-balance node))))
  171.     (lisp:1+ (lisp:max hl hr))))
  172.  
  173. (defmethod avl-maximum ((tree avl-tree))
  174.   (left-most (avl-root tree)))
  175.  
  176. (defmethod left-most ((node avl-node))
  177.   (labels ((find-left-most (node)
  178.          (cond ((null (avl-left node)) node)
  179.            (t (find-left-most (avl-left node))))))
  180.     (find-left-most node)))
  181.  
  182. (defmethod map-over-each-node ((tree avl-tree) function)
  183.   (labels ((map-over (node)
  184.          (unless (null (avl-left node))
  185.            (map-over (avl-left node)))
  186.          (%funcall function node)
  187.          (unless (null (avl-right node))
  188.            (map-over (avl-right node)))))
  189.     (let ((root (avl-root tree)))
  190.       (when root 
  191.     (map-over root)))))
  192.  
  193. (defmethod make-generator ((tree avl-tree))
  194.   (let (stack)
  195.     (macrolet ((current-state () `(first (first stack)))
  196.            (set-current-state (state) `(setf (first (first stack)) ,state))
  197.            (current-node () `(rest (first stack)))
  198.            (new-node (node) `(push (cons :left ,node) stack)))
  199.       (labels ((scan ()
  200.          (cond ((null stack) nil)
  201.                ((eql (current-state) :left) 
  202.             (cond ((null (avl-left (current-node))) 
  203.                    (set-current-state :right)
  204.                    (current-node))
  205.                   (t (set-current-state :here)
  206.                  (new-node (avl-left (current-node)))
  207.                  (scan))))
  208.                ((eql (current-state) :here)
  209.             (set-current-state :right)
  210.             (current-node))
  211.                (t ;; (eql (current-state) :right)
  212.             (cond ((null (avl-right (current-node)))
  213.                    (pop stack)
  214.                    (scan))
  215.                   (t (new-node
  216.                   (prog1 (avl-right (current-node))
  217.                     (pop stack)))
  218.                  (scan))))
  219.                )))
  220.     (new-node (avl-root tree))
  221.     #'scan))))    
  222.  
  223. (defmethod avl-minimum ((tree avl-tree))
  224.   (right-most (avl-root tree)))
  225.  
  226. (defmethod right-most ((node avl-node))
  227.   (labels ((find-right-most (node)
  228.          (cond ((null (avl-right node)) node)
  229.            (t (find-right-most (avl-right node))))))
  230.     (find-right-most node)))
  231.  
  232. (defmethod avl-next (key (tree avl-tree))
  233.   (avl-next key (avl-root tree)))
  234.  
  235. (defmethod avl-next (key (node avl-node))
  236.   (labels ((next-loop (node)
  237.          (and node
  238.           (if (not (> node key))
  239.               (next-loop (avl-right node))
  240.               (or (next-loop (avl-left node))
  241.               node)))))
  242.     (next-loop node)))
  243.  
  244. (defmethod avl-previous (key (tree avl-tree))
  245.   (avl-previous key (avl-root tree)))
  246.  
  247. (defmethod avl-previous (key (node avl-node))
  248.   (labels ((next-loop (node)
  249.          (and node
  250.           (if (not (> key node))
  251.               (next-loop (avl-left node))
  252.               (or (next-loop (avl-right node))
  253.               node)))))
  254.     (next-loop node)))
  255.  
  256.  
  257. ;; The first interesting operation on AVL trees. This inserts THING
  258. ;; into the tree and returns a new tree and an integer which is the
  259. ;; change in height of the tree.
  260.  
  261. (defmethod insert (item (tree avl-tree) &rest args)
  262.   (labels
  263.       ((avl-insert (node)
  264.      (if (null node)
  265.          (values (%apply #'make-element tree item args) 1)
  266.          (cond ((= item node)
  267.             (values        ;; Just update the value field if necessary
  268.               (%apply #'update-node node (avl-balance node)
  269.                  (avl-left node) (avl-right node)
  270.                  args)
  271.               0))
  272.            ((> item node) 
  273.             (multiple-value-bind (subtree height-change)
  274.             (avl-insert (avl-right node)) 
  275.               (setq node 
  276.                 (update-node node
  277.                      (lisp:+ (avl-balance node)
  278.                          height-change)
  279.                      (avl-left node) subtree))
  280.               (if (lisp:> (avl-balance node) 1)
  281.               (balance-right node 1)
  282.               (values node (if (lisp:plusp (avl-balance node))
  283.                        height-change
  284.                        0)))))
  285.            (t (multiple-value-bind (subtree height-change)
  286.               (avl-insert (avl-left node))
  287.             (setq node
  288.                   (update-node node
  289.                        (lisp:- (avl-balance node)
  290.                            height-change)
  291.                        subtree
  292.                        (avl-right node)))
  293.             (if (lisp:< (avl-balance node) -1)
  294.                 (balance-left node 1)
  295.                 (values node
  296.                     (if (lisp:minusp (avl-balance node))
  297.                     height-change
  298.                     0)))))))))
  299.     (setf (avl-root tree) (avl-insert (avl-root tree)))
  300.     tree))
  301.  
  302.  
  303. ;; Balance a TREE that is right-Koyaanisquatsi, i.e. the right subtree
  304. ;; is 2 levels higher than the left subtree. HEIGHT-CHANGE is the
  305. ;; height of TREE relative to its value before the delete/insert
  306. ;; operation. Balance-right returns a node and the height of that node
  307. ;; relative to the original height of TREE.
  308.  
  309. (defmethod balance-right ((node avl-node) height-change)
  310.   (let ((r (avl-right node)))
  311.     (cond ((lisp:plusp (avl-balance r))
  312.        (setq node (update-node node 0 (avl-left node) (avl-left r)))
  313.        (setq r (update-node r 0 node (avl-right r)))
  314.        (values r (1- height-change)))
  315.       ((lisp:zerop (avl-balance r))
  316.        (setq node (update-node node 1 (avl-left node) (avl-left r)))
  317.        (setq r (update-node r -1 node (avl-right r)))
  318.        (values r height-change))
  319.       (t (let ((lr (avl-left r)))
  320.            (setq r (update-node r (if (lisp:minusp (avl-balance lr)) 1 0)
  321.                     (avl-right lr) (avl-right r)))
  322.            (setq node (update-node node
  323.                        (if (lisp:plusp (avl-balance lr)) -1 0)
  324.                        (avl-left node) (avl-left lr)))
  325.            (setq lr (update-node lr 0 node r))
  326.            (values lr (1- height-change)))))))
  327.  
  328. ; Balance a TREE that is left-Koyaanisquatsi, i.e. the left subtree is
  329. ;; 2 levels higher than the right subtree. HEIGHT-CHANGE is the height
  330. ;; of TREE relative to its value before the delete/insert operation.
  331. ;; Balance-left returns a node and the height of that node relative to
  332. ;; the original height of TREE.
  333.  
  334. (defmethod balance-left ((node avl-node) height-change)
  335.   (let ((l (avl-left node)))
  336.     (cond ((lisp:minusp (avl-balance l))
  337.        (setq node (update-node node 0 (avl-right l) (avl-right node)))
  338.        (setq l (update-node l 0 (avl-left l) node))
  339.        (values l (1- height-change)))
  340.       ((lisp:zerop (avl-balance l))
  341.        (setq node (update-node node -1 (avl-right l) (avl-right node)))
  342.        (setq l (update-node l 1 (avl-left l) node))
  343.        (values l height-change))
  344.       (t (let ((rl (avl-right l)))
  345.            (setq l (update-node l (if (lisp:plusp (avl-balance rl)) -1 0)
  346.                     (avl-left l) (avl-left rl)))
  347.            (setq node (update-node node (if (lisp:minusp (avl-balance rl))
  348.                         1 0)
  349.                        (avl-right rl) (avl-right node)))
  350.            (setq rl (update-node rl 0 l node))
  351.            (values rl (1- height-change)))))))
  352.  
  353. ;; This deletes an entry from an AVL tree.
  354.  
  355. (defmethod delete (item (tree avl-tree) &rest rest)
  356.   (declare (ignore rest))
  357.   (let ((root (avl-root tree)))
  358.     (labels
  359.       ((delete-left (node parent)
  360.      (cond ((null node)
  361.         (values nil 0))
  362.            ((= item node)
  363.         (multiple-value-bind (new-left height-change) (erase-node node)
  364.           (setf (avl-left parent) new-left)
  365.           (values new-left height-change)))
  366.            (t (avl-delete node))))
  367.        (delete-right (node parent)
  368.      (cond ((null node)
  369.         (values nil 0))
  370.            ((= item node)
  371.         (multiple-value-bind (new-right height-change)
  372.             (erase-node node)
  373.           (setf (avl-right parent) new-right)
  374.           (values new-right height-change)))
  375.            (t (avl-delete node))))
  376.        (avl-delete (node)
  377.      (cond ((> item node)
  378.         (multiple-value-bind (subtree height-change)
  379.             (delete-right (avl-right node) node)
  380.           (setq node (update-node node
  381.                       (lisp:+ (avl-balance node)
  382.                           height-change)
  383.                       (avl-left node) subtree))
  384.           (if (lisp:< (avl-balance node) -1)
  385.               (balance-left node 0)
  386.               (values node (if (lisp:zerop (avl-balance node))
  387.                        height-change 0)))))
  388.            (t (multiple-value-bind (subtree height-change)
  389.               (delete-left (avl-left node) node)
  390.             (setq node (update-node node
  391.                         (lisp:- (avl-balance node)
  392.                             height-change)
  393.                         subtree (avl-right node)))
  394.             (if (lisp:> (avl-balance node) 1)
  395.             (balance-right node 0)
  396.             (values node (if (lisp:zerop (avl-balance node))
  397.                      height-change 0))))))))
  398.       (cond ((null root)
  399.          (values nil 0))
  400.         ((= item root)
  401.          (setf (avl-root tree) (erase-node root)))
  402.         ((> item root)
  403.          (delete-right (avl-right root) root))
  404.         (t (delete-left (avl-left root) root)))
  405.       tree)))
  406.  
  407. (defmethod member (item (tree avl-tree) &rest rest)
  408.   (declare (ignore rest))
  409.   (labels ((search-node (node)
  410.          (cond ((null node) nil)
  411.            ((= item node) node)
  412.            ((> item node)
  413.             (search-node (avl-right node)))
  414.            (t (search-node (avl-left node))))))
  415.     (search-node (avl-root tree))))
  416.  
  417. ;; This gets rid of a value that has been found in the tree. NODE is
  418. ;; the node containing the value. If the right subtree of NODE is
  419. ;; higher than its left, replace the value of NODE with the value of
  420. ;; the left-most leaf of the right subtree, and remove this leaf from
  421. ;; the right subtree. Otherwise replace NODE's value with the value of
  422. ;; the right-most leaf of the left subtree of NODE, and remove this
  423. ;; leaf from the left subtree.
  424.  
  425. (defmethod erase-node ((node avl-node))
  426.   (cond ((and (null (avl-left node)) (null (avl-right node)))
  427.      (values nil -1))
  428.     ((lisp:plusp (avl-balance node))
  429.      (multiple-value-bind (head-node subtree height-change)
  430.          (delete-head (avl-right node))
  431.        (setq node (update-node head-node
  432.                    (lisp:+ (avl-balance node)
  433.                        height-change)
  434.                    (avl-left node) subtree))
  435.        (values node height-change)))
  436.     (t (multiple-value-bind (tail-node subtree height-change)
  437.            (delete-tail (avl-left node))
  438.          (setq node (update-node tail-node
  439.                      (lisp:- (avl-balance node) height-change)
  440.                       subtree (avl-right node)))
  441.          (values node (if (lisp:zerop (avl-balance node))
  442.                   height-change 0))))))
  443.  
  444. ; This returns the head (leftmost element) in the tree, and removes it
  445. ;; from the tree.  Useful for implementing priority queues as AVL
  446. ;; trees.  Values returned are the value of the leftmost element, the
  447. ;; modified tree, and the change in height of the tree.
  448.  
  449. (defmethod delete-head ((tree avl-tree))  
  450.   (multiple-value-bind (tail new-root height-change)
  451.       (delete-head (avl-root tree))
  452.     (setf (avl-root tree) new-root)
  453.     (values tail height-change)))
  454.  
  455. (defmethod delete-head ((node avl-node))
  456.   (cond ((null node) nil)
  457.     ((null (avl-left node))
  458.      (values node (avl-right node) -1))
  459.     (t (multiple-value-bind (head-value subnode height-change)
  460.            (delete-head (avl-left node))
  461.          (setq node (update-node node (lisp:- (avl-balance node)
  462.                           height-change)
  463.                      subnode (avl-right node)))
  464.          (if (> (avl-balance node) 1)
  465.          (multiple-value-setq (node height-change)
  466.            (balance-right node 0))
  467.          (if (not (lisp:zerop (avl-balance node)))
  468.              (setq height-change 0)))
  469.          (values head-value node height-change))))) 
  470.  
  471. ; This returns the tail (rightmost element) in the tree, and removes
  472. ;; it from the tree.  Values returned are the value of the rightmost
  473. ;; element, the modified tree, and the change in height of the tree.
  474.  
  475. (defmethod delete-tail ((tree avl-tree))
  476.   (multiple-value-bind (tail new-root height-change)
  477.       (delete-tail (avl-root tree))
  478.     (setf (avl-root tree) new-root)
  479.     (values tail height-change)))
  480.  
  481. (defmethod delete-tail ((node avl-node))
  482.   (cond ((null node) nil)
  483.     ((null (avl-right node))
  484.      (values node (avl-left node) -1))
  485.     (t (multiple-value-bind (tail-value subnode height-change)
  486.            (delete-tail (avl-right node))
  487.          (setq node (update-node node (lisp:+ (avl-balance node)
  488.                           height-change)
  489.                      (avl-left node) subnode))
  490.          (if (lisp:< (avl-balance node) -1)
  491.          (multiple-value-setq (node height-change)
  492.            (balance-left node 0))
  493.          (if (not (lisp:zerop (avl-balance node)))
  494.              (setq height-change 0)))
  495.          (values tail-value node height-change)))))
  496.  
  497. (defmethod make-element ((tree avl-tree-elements-as-singletons) key &rest rest)
  498.   (declare (ignore rest))
  499.   (make-instance 'avl-node :domain tree :key key))
  500.  
  501. (defmethod make-element ((tree avl-tree-elements-as-pairs) key &rest rest)
  502.   (make-instance 'avl-node-as-pairs :domain tree :key key :value (first rest)))
  503.  
  504.